home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 015 / sfutil.arc / MAKEBOLD.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-03-29  |  14.6 KB  |  650 lines
  1. Program MakeBold;
  2.  
  3. {$B+}
  4. {$V-}
  5.  
  6. const
  7.    MaxChar = 255;
  8.  
  9. type
  10.    DoubIntg = array[1..2] of Integer;
  11.    String80 = String[80];
  12.    tRegs = record case boolean of
  13.             false: (Ax,Bx,Cx,Dx,Bp,Si,Di,Ds,Es,Flags: Integer);
  14.             true:  (Al,Ah,Bl,Bh,Cl,Ch,Dl,Dh: Byte);
  15.             end;
  16.  
  17.    tFontHdr = record
  18.                   C26:        Integer;
  19.                   CNull1:     Byte;
  20.                   FontType:   Byte;
  21.                   CNull2:     Integer;
  22.                   BaseLine:   Integer;
  23.                   Width:      Integer;
  24.                   Height:     Integer;
  25.                   Orient:     Byte;
  26.                   Fixed:      Byte;
  27.                   SymSet:     Integer;
  28.                   Pitch:      Integer;
  29.                   Points:     Integer;
  30.                   CNull3:     Integer;
  31.                   CNull4:     Byte;
  32.                   Style:      Byte;
  33.                   Weight:     Byte;
  34.                   TypeFace:   Byte;
  35.                   end;
  36.  
  37.    tCharHdr = record
  38.                   C4:         Byte;
  39.                   CNull1:     Byte;
  40.                   C14:        Byte;
  41.                   C1:         Byte;
  42.                   Orient:     Byte;
  43.                   CNull2:     Byte;
  44.                   LeftOffset: Integer;
  45.                   TopOffset:  Integer;
  46.                   CWidth:     Integer;
  47.                   CHeight:    Integer;
  48.                   DeltaX:     Integer;
  49.                   end;
  50.  
  51.    tBits = array[0..32767] of byte;
  52.    tpBits = ^tBits;
  53.  
  54.    tCharEnt =  record
  55.                   ChNbr:      Byte;
  56.                   Orient:     Byte;
  57.                   LeftOffset: Integer;
  58.                   TopOffset:  Integer;
  59.                   CWidth:     Integer;
  60.                   CHeight:    Integer;
  61.                   DeltaX:     Integer;
  62.                   CharLen:    Integer;
  63.                   CharPtr:    tpBits;
  64.                   end;
  65.    tFont =  record
  66.                FontType:   Byte;
  67.                BaseLine:   Integer;
  68.                Width:      Integer;
  69.                Height:     Integer;
  70.                Orient:     Byte;
  71.                Fixed:      Byte;
  72.                SymSet:     Integer;
  73.                Pitch:      Integer;
  74.                Points:     Integer;
  75.                Style:      Byte;
  76.                Weight:     Byte;
  77.                TypeFace:   Byte;
  78.                Chars:      array[0..MaxChar] of tCharEnt;
  79.                end;
  80.    tpFont = ^tFont;
  81.  
  82.    tFName = String[40];
  83.  
  84.    tMasks = array[0..7] of byte;
  85.  
  86. const
  87.    DefRegs: tRegs = (Ax:0;Bx:0;Cx:0;Dx:0;Bp:0;Si:0;Di:0;Ds:0;Es:0;Flags:0);
  88.    Masks: tMasks = ($80,$40,$20,$10,8,4,2,1);
  89.  
  90. var
  91.    FFile:      Integer;
  92.    FFName:     tFName;
  93.    FLen:       DoubIntg;
  94.    FPos:       DoubIntg;
  95.  
  96.    Font:       tpFont;
  97.  
  98.    MinCn:      Byte;
  99.    MaxCn:      Byte;
  100.  
  101.    Ch:         Char;
  102.  
  103. function GEDoubIntg(
  104.        V1:     DoubIntg;
  105.        V2:     DoubIntg): Boolean;
  106.  
  107.    var
  108.       Result: Boolean;
  109.  
  110.    begin {GEDoubIntg}
  111.  
  112.    if v1[1]>v2[1] then
  113.       Result:=true
  114.    else if v1[1]<v2[1] then
  115.       Result:=false
  116.    else if (v1[2]<0) and (v2[2]>=0) then
  117.       Result:=true
  118.    else if (v1[2]>=0) and (v2[2]<0) then
  119.       Result:=false
  120.    else
  121.       Result:= V1[2]>=V2[2];
  122.  
  123.    GEDoubIntg:=Result;
  124.  
  125.    end {GEDoubIntg};
  126.  
  127. procedure AddDoubIntg(
  128.    var V:      DoubIntg;
  129.        Offset: Integer);
  130.  
  131.    var
  132.       P1:   Integer;
  133.       P2:   Integer;
  134.  
  135.    begin {AddDoubIntg}
  136.  
  137.    P1:=V[2] and $FF;
  138.    P2:=V[2] shr 8;
  139.  
  140.    P1:=P1+Offset;
  141.  
  142.    P2:=P2+ (P1 shr 8);
  143.    P1:=P1 and $FF;
  144.  
  145.    V[1]:=V[1] + (P2 shr 8);
  146.    P2:=P2 and $FF;
  147.    V[2]:=(P2 shl 8) + P1;
  148.  
  149.    end {AddDoubIntg};
  150.  
  151. procedure CloseFont(
  152.    var FNbr:      Integer);
  153.  
  154.    var
  155.       Regs: tRegs;
  156.  
  157.    begin {CloseFont}
  158.  
  159.    if FNbr<>0 then
  160.       begin
  161.       Regs:=DefRegs;
  162.       Regs.Ah:=$3E;
  163.       Regs.Bx:=FNbr;
  164.       MsDos(Regs);
  165.       end;
  166.  
  167.    FNbr:=0;
  168.  
  169.    end {CloseFont};
  170.  
  171. procedure OpenFont(
  172.        Create:    Boolean;
  173.        Name:      tFName;
  174.    var FNbr:      Integer;
  175.    var FLen:      DoubIntg;
  176.    var Error:     Integer);
  177.  
  178.    var
  179.       Regs: tRegs;
  180.  
  181.    begin {OpenFont}
  182.  
  183.    Error:=0;
  184.  
  185.    if FNbr<>0 then
  186.       CloseFont(FNbr);
  187.  
  188.    Name[ord(Name[0])+1]:=#0;
  189.    Regs:=DefRegs;
  190.    if Create then
  191.       begin
  192.       Regs.Ax:=$3C00;
  193.       Regs.Cx:=32;
  194.       end
  195.    else
  196.       Regs.Ax:=$3D00;
  197.    Regs.Ds:=Seg(Name[1]);
  198.    Regs.Dx:=Ofs(Name[1]);
  199.    MsDos(Regs);
  200.    if odd(Regs.Flags) then
  201.       begin
  202.       Error:=Regs.Ax;
  203.       Regs.Ax:=0;
  204.       end;
  205.    FNbr:=Regs.Ax;
  206.  
  207.    if not Create and (Error=0) then
  208.       begin
  209.       Regs.Ah:=$42;
  210.       Regs.Al:=2;
  211.       Regs.Bx:=FNbr;
  212.       Regs.Cx:=0;
  213.       Regs.Dx:=0;
  214.       MsDos(Regs);
  215.       FLen[1]:=Regs.Dx;
  216.       FLen[2]:=Regs.Ax;
  217.       end;
  218.  
  219.  
  220.    end {OpenFont};
  221.  
  222. procedure MoveFromFont(
  223.        Nbr:          Integer;
  224.        FirstByte:    DoubIntg;
  225.    var Dest;
  226.        Len:          Integer);
  227.  
  228.    var
  229.       Regs:  tRegs;
  230.  
  231.    begin {MoveFromFont}
  232.  
  233.    Regs:=DefRegs;
  234.    with Regs do
  235.       begin
  236.       Ax:=$4200;
  237.       Bx:=Nbr;
  238.       Cx:=FirstByte[1];
  239.       Dx:=FirstByte[2];
  240.       end;
  241.    MsDos(Regs);
  242.  
  243.    Regs:=DefRegs;
  244.    with Regs do
  245.       begin
  246.       Ax:=$3F00;
  247.       Bx:=Nbr;
  248.       Cx:=Len;
  249.       Dx:=Ofs(Dest);
  250.       Ds:=Seg(Dest);
  251.       end;
  252.    MsDos(Regs);
  253.  
  254.    end {MoveFromFont};
  255.  
  256. procedure MoveToFont(
  257.        Nbr:          Integer;
  258.    var Src;
  259.        Len:          Integer);
  260.  
  261.    var
  262.       Regs:  tRegs;
  263.  
  264.    begin {MoveToFont}
  265.  
  266.    Regs:=DefRegs;
  267.    with Regs do
  268.       begin
  269.       Ax:=$4000;
  270.       Bx:=Nbr;
  271.       Cx:=Len;
  272.       Dx:=Ofs(Src);
  273.       Ds:=Seg(Src);
  274.       end;
  275.    MsDos(Regs);
  276.  
  277.    end {MoveToFont};
  278.  
  279. procedure GetFontNameAndOpen(
  280.        LabelStr:     String80;
  281.        Create:       Boolean;
  282.    var FontName:     tFName;
  283.    var FontFile:     Integer;
  284.    var FLen:         DoubIntg);
  285.  
  286.    var
  287.       IoStatus: Integer;
  288.       DumbFile: File;
  289.  
  290.    begin {GetFontNameAndOpen}
  291.  
  292.    repeat
  293.       FontFile:=0;
  294.       FontName:='';
  295.       write(trm,LabelStr);
  296.       readln(trm,fontname);
  297.       if length(fontname)>0 then
  298.          begin
  299.          if Create then
  300.             begin
  301.             Assign(DumbFile,FontName);
  302.       {$I-} Erase(DumbFile);  {$I+}
  303.             IoStatus:=IoResult;
  304.             end;
  305.          OpenFont(create,FontName,FontFile,FLen,IoStatus);
  306.          if iostatus<>0 then
  307.             begin
  308.             writeln(trm,^G'Open Error ',IoStatus:1);
  309.             read(kbd,ch);
  310.             if (Ch=^C) then
  311.                Halt;
  312.             end;
  313.          end
  314.       else
  315.          write(trm,^G);
  316.  
  317.    until IoStatus=0;
  318.  
  319.    end {GetFontNameAndOpen};
  320.  
  321. procedure GetNumber(
  322.    var Num:    Integer;
  323.    var Ch:     Char);
  324.  
  325.    begin
  326.  
  327.    num:=0;
  328.    repeat
  329.       MoveFromFont(FFile,fpos,ch,1);
  330.       if (Ch>='0') and (Ch<='9') then
  331.          begin
  332.          num:=10*num+(ord(ch)-48);
  333.          adddoubintg(fpos,1);
  334.          end;
  335.    until (Ch<'0') or (Ch>'9');
  336.  
  337.    end;
  338.  
  339. procedure GetFontHeader(
  340.    var FontHdr:   tFontHdr);
  341.  
  342.    var
  343.       Str:  String[3];
  344.       Num:  Integer;
  345.       Ch:   Char;
  346.  
  347.    begin
  348.  
  349.    MoveFromFont(FFile,fpos,str[1],3);
  350.    str[0]:=#3;
  351.    if str=^[')s' then
  352.       begin
  353.       AddDoubIntg(FPos,3);
  354.       GetNumber(Num,Ch);
  355.       AddDoubIntg(FPos,1);
  356.       MoveFromFont(FFile,FPos,FontHdr,26);
  357.       AddDoubIntg(FPos,Num);
  358.       end;
  359.  
  360.    end;
  361.  
  362. procedure GetCharId(
  363.    var Cn:  Byte);
  364.  
  365.    var
  366.       Str:  String[3];
  367.       Ch:   Char;
  368.       Num:  Integer;
  369.  
  370.    begin
  371.  
  372.    MoveFromFont(FFile,fpos,str[1],3);
  373.    str[0]:=#3;
  374.    if str=^['*c' then
  375.       begin
  376.       AddDoubIntg(FPos,3);
  377.       GetNumber(Num,Ch);
  378.       Cn:=Num;
  379.       AddDoubIntg(FPos,1);
  380.       end;
  381.  
  382.    end;
  383.  
  384. procedure GetCharDef(
  385.    var CharHdr:   tCharHdr;
  386.    var CharLen:   Integer);
  387.  
  388.    var
  389.       Str:  String[3];
  390.       Ch:   Char;
  391.       Num:  Integer;
  392.  
  393.    begin
  394.  
  395.    MoveFromFont(FFile,fpos,str[1],3);
  396.    str[0]:=#3;
  397.    if str=^['(s' then
  398.       begin
  399.       AddDoubIntg(FPos,3);
  400.       GetNumber(Num,Ch);
  401.       AddDoubIntg(FPos,1);
  402.       MoveFromFont(FFile,fpos,charhdr,16);
  403.       CharLen:=Num-16;
  404.       AddDoubIntg(FPos,16);
  405.       end;
  406.  
  407.    end;
  408.  
  409. procedure ReadFont;
  410.  
  411.    var
  412.       Ch:         Char;
  413.       Cn:         Byte;
  414.       FontHdr:    tFontHdr;
  415.       CharHdr:    tCharHdr;
  416.       RowWidth:   Integer;
  417.       CharSize0:  Integer;
  418.       CharSize:   Integer;
  419.       Ix:         Integer;
  420.       X:          Byte;
  421.  
  422.    begin {ReadFont}
  423.  
  424.    for cn:=0 to maxchar do
  425.       Font^.Chars[Cn].ChNbr:=0;
  426.  
  427.    GetFontNameAndOpen('Read Font: ',false,Ffname,FFile,FLen);
  428.    FPos[1]:=0;
  429.    FPos[2]:=0;
  430.  
  431.    if FFile>0 then
  432.       begin
  433.       GetFontHeader(FontHdr);
  434.       Font^.FontType:=FontHdr.FontType;
  435.       Font^.BaseLine:=swap(FontHdr.BaseLine);
  436.       Font^.Width:=swap(FontHdr.Width);
  437.       Font^.Height:=swap(FontHdr.Height);
  438.       Font^.Orient:=FontHdr.Orient;
  439.       Font^.Fixed:=FontHdr.Fixed;
  440.       Font^.SymSet:=swap(FontHdr.SymSet);
  441.       Font^.Pitch:=swap(FontHdr.Pitch);
  442.       Font^.Points:=swap(FontHdr.Points);
  443.       Font^.Style:=FontHdr.Style;
  444.       Font^.Weight:=FontHdr.Weight;
  445.       Font^.TypeFace:=FontHdr.TypeFace;
  446.  
  447.       mincn:=255;
  448.       maxcn:=0;
  449.  
  450.       while not GEDoubIntg(FPos,FLen) do
  451.          begin
  452.          GetCharId(Cn);
  453.          GetCharDef(CharHdr,CharSize0);
  454.          if cn<mincn then
  455.             mincn:=cn;
  456.          if cn>maxcn then
  457.             maxcn:=cn;
  458.          write(trm,^M^['K',cn:1);
  459.          with Font^.Chars[cn] do
  460.             begin
  461.             ChNbr:=Cn;
  462.             Orient:=CharHdr.Orient;
  463.             LeftOffset:=swap(CharHdr.LeftOffset);
  464.             TopOffset:=swap(CharHdr.TopOffset);
  465.             CWidth:=swap(CharHdr.CWidth);
  466.             CHeight:=swap(CharHdr.CHeight);
  467.             DeltaX:=swap(CharHdr.DeltaX) div 4;
  468.             RowWidth:=(CWidth+7) shr 3; {width at old size}
  469.             CharSize:=((CWidth+8) shr 3)*CHeight; {size at new size}
  470.             CharLen:=CharSize;
  471.             GetMem(CharPtr,CharSize);
  472.             CWidth:=CWidth+1;
  473.             DeltaX:=DeltaX+1;
  474.             if CharSize=CharSize0 then
  475.                begin
  476.                MoveFromFont(FFile,FPos,CharPtr^,CharSize);
  477.                AddDoubIntg(FPos,CharSize);
  478.                end
  479.             else begin {Need to add one byte per row}
  480.                Ix:=0;
  481.                Repeat
  482.                   MoveFromFont(FFile,FPos,CharPtr^[Ix],RowWidth);
  483.                   AddDoubIntg(FPos,RowWidth);
  484.                   Ix:=Ix+RowWidth;
  485.                   CharPtr^[Ix]:=0;
  486.                   Ix:=Ix+1;
  487.                until Ix>=CharSize;
  488.                end;
  489.             end;
  490.          X:=0;
  491.          while (X=0) and not GEDoubIntg(FPos,FLen) do
  492.             begin
  493.             MoveFromFont(FFile,FPos,X,1);
  494.             if X=0 then
  495.                AddDoubIntg(FPos,1);
  496.             end;
  497.          end;
  498.  
  499.       CloseFont(FFile);
  500.       end;
  501.    writeln(trm);
  502.  
  503.    end {ReadFont};
  504.  
  505. procedure WriteFont;
  506.  
  507.    var
  508.       Ch:         Char;
  509.       Cn:         Byte;
  510.       R:          Byte;
  511.       NChars:     Byte;
  512.       WFName:     tFName;
  513.       FFile:      Integer;
  514.       IoStatus:   Integer;
  515.       ErrStr:     String[5];
  516.       NumStr:     String[5];
  517.       WString:    String80;
  518.       FLen:       DoubIntg;
  519.       FPos:       DoubIntg;
  520.       FontHdr:    tFontHdr;
  521.       CharHdr:    tCharHdr;
  522.       Regs:       tRegs;
  523.  
  524.    begin {WriteFont}
  525.  
  526.    GetFontNameAndOpen('Write Font: ',true,WFName,FFile,FLen);
  527.  
  528.    if FFile>0 then
  529.       begin
  530.       FontHdr.C26:=64 shl 8;
  531.       FontHdr.CNull1:=0;
  532.       FontHdr.CNull2:=0;
  533.       FontHdr.CNull3:=0;
  534.       FontHdr.CNull4:=0;
  535.  
  536.       FontHdr.FontType:=Font^.FontType;
  537.       FontHdr.BaseLine:=swap(Font^.BaseLine);
  538.       FontHdr.Width:=swap(Font^.Width);
  539.       FontHdr.Height:=swap(Font^.Height);
  540.       FontHdr.Orient:=Font^.Orient;
  541.       FontHdr.Fixed:=Font^.Fixed;
  542.       FontHdr.SymSet:=swap(Font^.SymSet);
  543.       FontHdr.Pitch:=swap(Font^.Pitch);
  544.       FontHdr.Points:=swap(Font^.Points);
  545.       FontHdr.Style:=Font^.Style;
  546.       FontHdr.Weight:=Font^.Weight;
  547.       FontHdr.TypeFace:=Font^.TypeFace;
  548.  
  549.       Str(sizeof(tFontHdr):1,NumStr);
  550.       WString:=^[')s'+NumStr+'W';
  551.       MoveToFont(FFile,WString[1],ord(WString[0]));
  552.       MoveToFont(FFile,FontHdr,sizeof(tFontHdr));
  553.  
  554.       for Cn:=0 to MaxChar do
  555.          if Font^.Chars[Cn].ChNbr<>0 then with Font^.Chars[Cn] do
  556.             begin
  557.             CharHdr.C4:=4;
  558.             CharHdr.CNull1:=0;
  559.             CharHdr.C14:=14;
  560.             CharHdr.C1:=1;
  561.             CharHdr.CNull2:=0;
  562.  
  563.             CharHdr.Orient:=Orient;
  564.             CharHdr.LeftOffset:=swap(LeftOffset);
  565.             CharHdr.TopOffset:=swap(TopOffset);
  566.             CharHdr.CWidth:=swap(CWidth);
  567.             CharHdr.CHeight:=swap(CHeight);
  568.             CharHdr.DeltaX:=swap(4*DeltaX);
  569.  
  570.             write(trm,^M^['K',Cn:1);
  571.             Str(Font^.Chars[Cn].ChNbr:1,NumStr);
  572.             WString:=^['*c'+NumStr+'E';
  573.             MoveToFont(FFile,WString[1],ord(Wstring[0]));
  574.  
  575.             Str((sizeof(tCharHdr)+CharLen):1,NumStr);
  576.             WString:=^['(s'+NumStr+'W';
  577.             MoveToFont(FFile,WString[1],ord(Wstring[0]));
  578.  
  579.             MoveToFont(FFile,CharHdr,sizeof(tCharHdr));
  580.             MoveToFont(FFile,CharPtr^,CharLen);
  581.  
  582.             end;
  583.  
  584.       CloseFont(FFile);
  585.       end;
  586.    writeln(trm);
  587.  
  588.  
  589.    end {WriteFont};
  590.  
  591. procedure EmboldenFont;
  592.  
  593.    var
  594.       Cn:         Byte;
  595.       MaxWidth:   Byte;
  596.       RowWidth:   Integer;
  597.       R:          Byte;
  598.       Iy:         Integer;
  599.       Ix:         Integer;
  600.  
  601.  
  602.    begin {EmboldenFont}
  603.  
  604.    MaxWidth:=0;
  605.    Font^.Weight:=3;
  606.  
  607.    for Cn:=0 to MaxChar do
  608.       if Font^.Chars[Cn].ChNbr<>0 then with Font^.Chars[Cn] do
  609.          begin
  610.          if CWidth>MaxWidth then
  611.             MaxWidth:=CWidth;
  612.          RowWidth:=((CWidth+7) shr 3);
  613.          iy:=CharLen-1;
  614.          for r:=CHeight downto 1 do
  615.             begin
  616.             for ix:=RowWidth downto 1 do
  617.                begin
  618.                CharPtr^[Iy]:=CharPtr^[Iy] or (CharPtr^[Iy] shr 1);
  619.                if ix>1 then
  620.                   CharPtr^[Iy]:=CharPtr^[Iy] or
  621.                                     ((CharPtr^[Iy-1] and 1) shl 7);
  622.                iy:=iy-1;
  623.                end;
  624.             end;
  625.          write(trm,^M^['K',Cn:1);
  626.          end;
  627.    writeln(trm);
  628.  
  629.    if MaxWidth>Font^.Width then
  630.       Font^.Width:=MaxWidth;
  631.  
  632.    end {EmboldenFont};
  633.  
  634. begin
  635.  
  636. DefRegs.Ds:=DSeg;
  637. DefRegs.Es:=DSeg;
  638.  
  639. new(Font);
  640.  
  641. writeln(trm,^['H'^['J');
  642.  
  643. ReadFont;
  644.  
  645. EmboldenFont;
  646.  
  647. WriteFont;
  648.  
  649. end.
  650.